perm filename T2.FRT[M11,LCS] blob sn#398784 filedate 1978-11-24 generic text, type T, neo UTF8
C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C INTO THE IX ARRAY.  IX ARRAY ADVANCES 2 WORDS AT A TIME.
C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
C KCNT IS WORD COUNT OF INPUT STRING.
        SUBROUTINE MPACK(KCNT, I,IX,IPTR)
	COMMON/IGEN/IGEN
	COMMON /TR/Q(80),QX(100),IIX(100),LX(12),INST(27,5),MX5(40)
	DIMENSION I(1)
	DATA IPP/'P'/,IFF/'F'/,IBB/'B'/,IAA/'A'/,IOO/'O'/,IRR/'R'/,
	1 IEE/'E'/,ISS/'S'/,IMM/'M'/,III/'I'/,ILL/'L'/,ITT/'T'/,
	1 IDD/'D'/,I2/'2'/,I3/'3'/,I4/'4'/,IUU/'U'/,ICC/'C'/,IHH/'H'/
	1,IVV/'V'/,IYY/'Y'/IWW/'W'/,I0/'0'/,I9/'9'/,INN/'N'/,IQQ/'Q'/
	1,IPP/'P'/,IGG/'G'/
	IX=I(1)
	DO 100 K=1,12
	IF(IX.NE.LX(K))GO TO 100
C LOOK FOR PUNCTUATION, ARITHMETIC OPERATORS, ETC.
	RETURN
100	CONTINUE
101	N=I(2)
	L=I(3)
	IF(IGEN.NE.2)GO TO 1000
C IGEN=2=READING INSTRUMENT DEFINITION
CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,SET,RAH,END,INS
	IF(IX.EQ.IPP)GO TO 14
	IF(IX.EQ.IFF)GO TO 15
	IF(IX.EQ.IBB)GO TO 16
	IF(IX.EQ.IAA)GO TO 1
	IF(IX.EQ.IOO)GO TO 2
	IF(IX.EQ.IRR)GO TO 3
	IF(IX.EQ.IEE)GO TO 4
	IF(IX.EQ.ISS)GO TO 5
	IF(IX.EQ.IMM)GO TO 17   
	IF(IX.EQ.III)GO TO 33
C IF NOT A KNOWN WORD THEN ERROR
999	CALL ERR(5)
C NEXT FOR 'MLT'
17	IF(N.NE.ILL)GO TO 999
	IF(L.NE.ITT)GO TO 999
	IX=9
	RETURN
1	IF(N.NE.IDD)GO TO 999
	IF(L.EQ.I2)GO TO 6
C 'AD2, AD3, AD4'
	IF(L.EQ.I3)GO TO 7
	IF(L.NE.I4)GO TO 999
	IX=8
	RETURN
6	IX=3
	RETURN
7	IX=7
	RETURN
2	IF(N.EQ.ISS)GO TO 10
	IF(N.NE.IUU)GO TO 999
	IF(L.NE.ITT)GO TO 999
C 'OUT'
	IX=1
	RETURN
10	IF(L.NE.ICC)GO TO 999
C 'OSC'
	IX=2
	RETURN
3	IF(N.NE.IAA)GO TO 999
	IF(L.EQ.INN)GO TO 11
	IF(L.NE.IHH)GO TO 999
C 'RAN', 'RAH'
	IX=11
	RETURN
11	IX=4
	RETURN
4	IF(N.NE.INN)GO TO 999
	IF(L.EQ.IVV)GO TO 12
C ENV, END
	IF(L.NE.IDD)GO TO 999
	IX=12
	RETURN
12	IX=5
	RETURN
5	IF(N.EQ.ITT)GO TO 13
	IF(N.NE.IEE)GO TO 999
C SET, STR
	IF(L.NE.ITT)GO TO 999
	IX=10
	RETURN
13	IF(L.NE.IRR)GO TO 999
	IX=6
	RETURN
14	J=200
C PN
18	IF(N.LT.I0.OR.N.GT.I9)GO TO 999
	K2=0
	K1=N-8240
C  CONVERTS ASCII CHAR. TO INTEGER ('0'=8240)
	IF(KCNT.EQ.2)GO TO 19
C ARE THERE 2 DIGITS AFTER P, F OR B?
	IF(L.LT.I0.OR.L.GT.I9)GO TO 999
	K1=K1*10
	K2=L-8240
19	IX=J+K1+K2
	RETURN
15	J=300
C  FN
	GO TO 18
16	J=100
C BN
	GO TO 18

C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
1000	IF(KCNT.LE.3)GO TO 2000
C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
	LN=I(4)
	IF(IX.EQ.IPP)GO TO 20
C THIS LIST BEGINS WITH CODE NUM. 400:
C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,GEN,DUR,FREQ,INSTRU,UNIT GEN.
	IF(IX.EQ.IFF)GO TO 21
	IF(IX.EQ.ISS)GO TO 22
	IF(IX.EQ.INN)GO TO 23
	IF(IX.EQ.III)GO TO 27
	IF(IX.NE.IUU)GO TO 28
C JUMP IF NOT ONE OF THE SPECIAL WORDS. IT MAY BE AN INSTR.
C****** INSTRS CANNOT HAVE SAME NAME(1ST 4 LTRS) AS ANY OF THESE WORDS*******
	IF(N.NE.INN)GO TO 28
	IF(L.NE.III)GO TO 28
	IF(LN.NE.ITT)GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
	IX=413
	RETURN
20	IF(N.NE.ILL)GO TO 30
	IF(L.NE.IAA)GO TO 28
	IF(LN.NE.IYY)GO TO 28
C PLAY
	IX=400
	RETURN
30	IF(N.NE.IRR)GO TO 31
	IF(L.NE.III)GO TO 28
	IF(LN.NE.INN)GO TO 28
C PRINT
	IX=404
	RETURN
31	IF(N.NE.IOO)GO TO 28
	IF(L.NE.IWW)GO TO 28
	IF(LN.NE.IEE)GO TO 28
C POWER(X,Y)
	IX=406
	RETURN
21	IF(N.NE.III)GO TO 32
	IF(L.NE.INN)GO TO 28
	IF(LN.NE.III)GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
	IX=401
	RETURN
22	IF(N.NE.IRR)GO TO 28
	IF(L.EQ.ITT.AND.KCNT.EQ.3)GO TO 222
	IF(L.NE.IAA)GO TO 29
	IF(LN.NE.ITT)GO TO 28
C SRATE, SRT
222	IX=402
	RETURN
29	IF(L.NE.ITT)GO TO 28
	IX=407
	RETURN
23	IF(N.NE.ICC)GO TO 28
	IF(L.NE.IHH)GO TO 28
	IF(LN.NE.INN)GO TO 28
C NCHNS
	IX=403
	RETURN
24	IF(N.NE.IHH)GO TO 28
	IF(L.NE.IAA)GO TO 28
C CHA 
	IX=405
	RETURN
25	IF(N.NE.IEE)GO TO 28
	IF(L.NE.INN)GO TO 28
C  GEN 
	IX=409
	RETURN
26	IF(N.NE.IUU)GO TO 28
	IF(L.NE.IRR)GO TO 28
C DUR
	IX=410
	RETURN
27	IF(N.NE.INN)GO TO 28
	IF(L.NE.ISS)GO TO 28
	IF(KCNT.EQ.3)GO TO 33
	IF(LN.NE.ITT)GO TO 28
	IF(I(5).NE.IRR)GO TO 28
	IF(I(6).NE.IUU)GO TO 28
C INSTRUMENT
	IX=412
	RETURN
33	IX=13
C 'INS'
	RETURN
32	IF(N.NE.IRR)GO TO 28
	IF(L.NE.IEE)GO TO 28
	IF(LN.NE.IQQ)GO TO 28
C FREQ
	IX=411
	RETURN
28	IX=-IPTR
C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
	RETURN

2000	IF(IX.EQ.IPP)GO TO 14
C FINDS (P1, P21, ETC.)
	IF(IX.EQ.ISS)GO TO 22
C 'SRT'
	IF(IX.NE.IFF)GO TO 34
C A FUNC??
	IF(N.GE.I0.AND.N.LE.I9)GO TO 15
	IF(KCNT.EQ.3)GO TO 28
	IX=510
	GO TO 36
34	IF(IX.NE.ICC)GO TO 35
	IF(KCNT.EQ.3)GO TO 24
C JUMP IF NOT A NOTE
	IX=501
C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520  (CF TO BS)
	GO TO 36
35	IF(IX.NE.IGG)GO TO 38
C NOW A 'GEN' OR A NOTE
	IF(KCNT.EQ.3)GO TO 25
	IX=513
C THE NOTE 'G'
36	IF(KCNT.EQ.1)RETURN
	IF(N.EQ.IFF)GO TO 39
	IF(N.NE.ISS) GO TO 28
C NOW IT'S NOT A NOTE
40	IX=IX+1
C SHARP
	RETURN
39	IX=IX-1
C FLAT
	RETURN
38	IF(IX.NE.IDD)GO TO 41
	IF(KCNT.EQ.3)GO TO 26
C GO LOOK FOR 'DUR'
	IX=504
	GO TO 36
41	IF(IX.EQ.III)GO TO 27
C CATCHES  'INS'
	IF(IX.NE.IEE)GO TO 42
	IF(KCNT.EQ.3)GO TO 4
C 'END' OR NOTE 'E'?
	IX=507
	GO TO 36
42	IF(KCNT.EQ.3)GO TO 28
	IF(IX.NE.IAA)GO TO 43
	IX=516
	GO TO 36
43	IF(IX.NE.IBB)GO TO 28
	IX=519
	GO TO 36

	END

      SUBROUTINE ERR(N)
      GO TO (1,2,3,4,5)N
1      TYPE 101
      STOP
101      FORMAT(' MISSING SEMICOLON')
2      TYPE 102
      STOP
102      FORMAT(' MISSING PARENTHESIS')
3      TYPE 103
      STOP
103      FORMAT(' MISSING COMMA')
4      TYPE 104
104      FORMAT(' MISSING PLAY;')
5	TYPE 105
105	FORMAT(' UNKNOWN WORD')
      STOP
      END

      SUBROUTINE ARITH(Y,W,LL)
      DIMENSION W(1)
      COMMON /AR/IOP
47      X=W(LL-1)
      GO TO (41,42,43,44),IOP
41      X=X*Y
      GO TO 45
42      X=X/Y
      GO TO 45
43      X=X-Y
      GO TO 45
44      X=X+Y
45      W(LL-1)=X
      END